home *** CD-ROM | disk | FTP | other *** search
/ NeXTSTEP 3.3 (Developer)…68k, x86, SPARC, PA-RISC] / NeXTSTEP 3.3 Dev Intel.iso / NextDeveloper / Source / GNU / emacs / src / vmsfns.c < prev    next >
C/C++ Source or Header  |  1992-01-19  |  27KB  |  983 lines
  1. /* VMS subprocess and command interface.
  2.    Copyright (C) 1987, 1988 Free Software Foundation, Inc.
  3.  
  4. This file is part of GNU Emacs.
  5.  
  6. GNU Emacs is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 1, or (at your option)
  9. any later version.
  10.  
  11. GNU Emacs is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with GNU Emacs; see the file COPYING.  If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. /* Written by Mukesh Prasad.  */
  21.  
  22. /*
  23.  * INTERFACE PROVIDED BY EMACS FOR VMS SUBPROCESSES:
  24.  *
  25.  *    Emacs provides the following functions:
  26.  *
  27.  *      "spawn-subprocess", which takes as arguments:
  28.  *
  29.  *      (i)   an integer to identify the spawned subprocess in future
  30.  *              operations,
  31.  *      (ii)  A function to process input from the subprocess, and
  32.  *      (iii) A function to be called upon subprocess termination.
  33.  *
  34.  *      First argument is required.  If second argument is missing or nil,
  35.  *      the default action is to insert all received messages at the current
  36.  *      location in the current buffer.  If third argument is missing or nil,
  37.  *      no action is taken upon subprocess termination.
  38.  *    The input-handler is called as
  39.  *        (input-handler num string)
  40.  *    where num is the identifying integer for the subprocess and string
  41.  *    is a string received from the subprocess.  exit-handler is called
  42.  *    with the identifying integer as the argument.
  43.  *
  44.  *      "send-command-to-subprocess" takes two arguments:
  45.  *
  46.  *      (i)   Subprocess identifying integer.
  47.  *        (ii)  String to send as a message to the subprocess.
  48.  *
  49.  *      "stop-subprocess" takes the subprocess identifying integer as
  50.  *      argument.
  51.  *
  52.  *  Implementation is done by spawning an asynchronous subprocess, and
  53.  *  communicating to it via mailboxes.
  54.  */
  55.  
  56. #ifdef VMS
  57.  
  58. #include <stdio.h>
  59. #include <ctype.h>
  60. #undef NULL
  61.  
  62. #include "config.h"
  63. #include "lisp.h"
  64. #include <descrip.h>
  65. #include <dvidef.h>
  66. #include <prvdef.h>
  67. #include <clidef.h>
  68. #include <iodef.h>
  69. #include <ssdef.h>
  70. #include <errno.h>
  71.  
  72. /* GCC does not carry this header file.  Doesn't matter, we define the symbol
  73.    we need below, if not already defined.  */
  74. #ifndef __GNUC__
  75. #include <syidef.h>
  76. #endif
  77.  
  78. #ifdef VMS4_4   /* I am being cautious; perhaps this exists in older versions */
  79. #include <jpidef.h>
  80. #endif
  81.  
  82. #ifndef CLI$M_NOWAIT
  83. #define    CLI$M_NOWAIT    1    /* clidef.h is missing from C library */
  84. #endif
  85.  
  86. #ifndef SYI$_VERSION
  87. #define    SYI$_VERSION    4096    /* syidef.h is missing from C library */
  88. #endif
  89.  
  90. #ifndef JPI$_CLINAME
  91. #define    JPI$_CLINAME    522    /* JPI$_CLINAME is missing from jpidef.h */
  92. #endif
  93.  
  94. #ifndef JPI$_MASTER_PID
  95. #define    JPI$_MASTER_PID    805    /* JPI$_MASTER_PID missing from jpidef.h */
  96. #endif
  97. #define    LIB$_NOSUCHSYM    1409892 /* libclidef.h missing */
  98.  
  99. #define    MSGSIZE    160        /* Maximum size for mailbox operations */
  100.  
  101. #ifndef PRV$V_ACNT
  102.  
  103. /* these defines added as hack for VMS 5.1-1.   SJones, 8-17-89 */
  104. /* this is _really_ nasty and needs to be changed ASAP - should see about
  105.    using the union defined in SYS$LIBRARY:PRVDEF.H under v5 */
  106.  
  107. #define PRV$V_ACNT    0x09
  108. #define PRV$V_ALLSPOOL  0x04
  109. #define PRV$V_ALTPRI    0x0D
  110. #define PRV$V_BUGCHK    0x17
  111. #define PRV$V_BYPASS    0x1D
  112. #define PRV$V_CMEXEC    0x01
  113. #define PRV$V_CMKRNL    0x00
  114. #define PRV$V_DETACH    0x05
  115. #define PRV$V_DIAGNOSE  0x06
  116. #define PRV$V_DOWNGRADE 0x21
  117. #define PRV$V_EXQUOTA   0x13
  118. #define PRV$V_GROUP     0x08
  119. #define PRV$V_GRPNAM    0x03
  120. #define PRV$V_GRPPRV     0x22
  121. #define PRV$V_LOG_IO    0x07
  122. #define PRV$V_MOUNT     0x11
  123. #define PRV$V_NETMBX    0x14
  124. #define PRV$V_NOACNT    0x09
  125. #define PRV$V_OPER      0x12
  126. #define PRV$V_PFNMAP    0x1A
  127. #define PRV$V_PHY_IO    0x16
  128. #define PRV$V_PRMCEB    0x0A
  129. #define PRV$V_PRMGBL    0x18
  130. #define PRV$V_PRMJNL     0x25
  131. #define PRV$V_PRMMBX    0x0B
  132. #define PRV$V_PSWAPM    0x0C
  133. #define PRV$V_READALL     0x23
  134. #define PRV$V_SECURITY     0x26
  135. #define PRV$V_SETPRI    0x0D
  136. #define PRV$V_SETPRV    0x0E
  137. #define PRV$V_SHARE     0x1F
  138. #define PRV$V_SHMEM     0x1B
  139. #define PRV$V_SYSGBL    0x19
  140. #define PRV$V_SYSLCK    0x1E
  141. #define PRV$V_SYSNAM    0x02
  142. #define PRV$V_SYSPRV    0x1C
  143. #define PRV$V_TMPJNL     0x24
  144. #define PRV$V_TMPMBX    0x0F
  145. #define PRV$V_UPGRADE     0x20
  146. #define PRV$V_VOLPRO    0x15
  147. #define PRV$V_WORLD     0x10
  148. #endif
  149.  
  150. /* IO status block for mailbox operations.  */
  151. struct mbx_iosb
  152. {
  153.   short status;
  154.   short size;
  155.   int   pid;
  156. };
  157.  
  158. /* Structure for maintaining linked list of subprocesses.  */
  159. struct process_list
  160. {
  161.   int name;            /* Numeric identifier for subprocess */
  162.   int process_id;        /* VMS process address */
  163.   int process_active;        /* 1 iff process has not exited yet */
  164.   int mbx_chan;            /* Mailbox channel to write to process */
  165.   struct mbx_iosb iosb;        /* IO status block for write operations */
  166.   Lisp_Object input_handler;    /* Input handler for subprocess */
  167.   Lisp_Object exit_handler;    /* Exit handler for subprocess */
  168.   struct process_list * next;    /* Linked list chain */
  169. };
  170.  
  171. /* Structure for privilege list.  */
  172. struct privilege_list
  173. {
  174.   char * name;
  175.   int  mask;
  176. };
  177.  
  178. /* Structure for finding VMS related information.  */
  179. struct vms_objlist
  180. {
  181.   char * name;            /* Name of object */
  182.   Lisp_Object (* objfn)();    /* Function to retrieve VMS object */
  183. };
  184.  
  185. static int exit_ast ();        /* Called upon subprocess exit */
  186. static int create_mbx ();    /* Creates mailbox */
  187. static void mbx_msg ();        /* Writes null terminated string to mbx */
  188. static void write_to_mbx ();    /* Writes message to string */
  189. static void start_mbx_input ();    /* Queues I/O request to mailbox */
  190.  
  191. static int input_mbx_chan = 0;    /* Channel to read subprocess input on */
  192. static char input_mbx_name[20];
  193.                 /* Storage for mailbox device name */
  194. static struct dsc$descriptor_s input_mbx_dsc;
  195.                 /* Descriptor for mailbox device name */
  196. static struct process_list * process_list = 0;
  197.                 /* Linked list of subprocesses */
  198. static char mbx_buffer[MSGSIZE];
  199.                 /* Buffer to read from subprocesses */
  200. static struct mbx_iosb input_iosb;
  201.                 /* IO status block for mailbox reads */
  202.  
  203. int have_process_input,        /* Non-zero iff subprocess input pending */
  204.     process_exited;        /* Non-zero iff suprocess exit pending */
  205.  
  206. /* List of privilege names and mask offsets */
  207. static struct privilege_list priv_list[] = {
  208.  
  209.     { "ACNT",        PRV$V_ACNT },
  210.     { "ALLSPOOL",    PRV$V_ALLSPOOL },
  211.     { "ALTPRI",        PRV$V_ALTPRI },
  212.     { "BUGCHK",        PRV$V_BUGCHK },
  213.     { "BYPASS",        PRV$V_BYPASS },
  214.     { "CMEXEC",        PRV$V_CMEXEC },
  215.     { "CMKRNL",        PRV$V_CMKRNL },
  216.     { "DETACH",        PRV$V_DETACH },
  217.     { "DIAGNOSE",    PRV$V_DIAGNOSE },
  218.     { "DOWNGRADE",    PRV$V_DOWNGRADE }, /* Isn't VMS as low as you can go?  */
  219.     { "EXQUOTA",    PRV$V_EXQUOTA },
  220.     { "GRPPRV",        PRV$V_GRPPRV },
  221.     { "GROUP",        PRV$V_GROUP },
  222.     { "GRPNAM",        PRV$V_GRPNAM },
  223.     { "LOG_IO",        PRV$V_LOG_IO },
  224.     { "MOUNT",        PRV$V_MOUNT },
  225.     { "NETMBX",        PRV$V_NETMBX },
  226.     { "NOACNT",        PRV$V_NOACNT },
  227.     { "OPER",        PRV$V_OPER },
  228.     { "PFNMAP",        PRV$V_PFNMAP },
  229.     { "PHY_IO",        PRV$V_PHY_IO },
  230.     { "PRMCEB",        PRV$V_PRMCEB },
  231.     { "PRMGBL",        PRV$V_PRMGBL },
  232.     { "PRMJNL",        PRV$V_PRMJNL },
  233.     { "PRMMBX",        PRV$V_PRMMBX },
  234.     { "PSWAPM",        PRV$V_PSWAPM },
  235.     { "READALL",    PRV$V_READALL },
  236.     { "SECURITY",    PRV$V_SECURITY },
  237.     { "SETPRI",        PRV$V_SETPRI },
  238.     { "SETPRV",        PRV$V_SETPRV },
  239.     { "SHARE",         PRV$V_SHARE },
  240.     { "SHMEM",        PRV$V_SHMEM },
  241.     { "SYSGBL",        PRV$V_SYSGBL },
  242.     { "SYSLCK",        PRV$V_SYSLCK },
  243.     { "SYSNAM",        PRV$V_SYSNAM },
  244.     { "SYSPRV",        PRV$V_SYSPRV },
  245.     { "TMPJNL",        PRV$V_TMPJNL },
  246.     { "TMPMBX",        PRV$V_TMPMBX },
  247.     { "UPGRADE",    PRV$V_UPGRADE },
  248.     { "VOLPRO",        PRV$V_VOLPRO },
  249.     { "WORLD",        PRV$V_WORLD },
  250.  
  251.     };
  252.  
  253. static Lisp_Object
  254.           vms_account(), vms_cliname(), vms_owner(), vms_grp(), vms_image(),
  255.           vms_parent(), vms_pid(), vms_prcnam(), vms_terminal(), vms_uic_int(),
  256.       vms_uic_str(), vms_username(), vms_version_fn(), vms_trnlog(),
  257.       vms_symbol(), vms_proclist();
  258.  
  259. /* Table of arguments to Fvms_object, and the handlers that get the data.  */
  260.  
  261. static struct vms_objlist vms_object [] = {
  262.     { "ACCOUNT",    vms_account },    /* Returns account name as a string */
  263.     { "CLINAME",    vms_cliname },    /* Returns CLI name (string) */
  264.     { "OWNER",        vms_owner },    /* Returns owner process's PID (int) */
  265.     { "GRP",        vms_grp },    /* Returns group number of UIC (int) */
  266.     { "IMAGE",        vms_image },    /* Returns executing image (string) */
  267.     { "PARENT",        vms_parent },    /* Returns parent proc's PID (int) */
  268.     { "PID",        vms_pid },    /* Returns process's PID (int) */
  269.     { "PRCNAM",        vms_prcnam },    /* Returns process's name (string) */
  270.     { "TERMINAL",    vms_terminal },    /* Returns terminal name (string) */
  271.     { "UIC",        vms_uic_int },    /* Returns UIC as integer */
  272.     { "UICGRP",        vms_uic_str },    /* Returns UIC as string */
  273.     { "USERNAME",    vms_username },    /* Returns username (string) */
  274.     { "VERSION",    vms_version_fn },/* Returns VMS version (string) */
  275.     { "LOGICAL",    vms_trnlog },    /* Translates VMS logical name */
  276.     { "DCL-SYMBOL",    vms_symbol },    /* Translates DCL symbol */
  277.     { "PROCLIST",    vms_proclist },    /* Returns list of all PIDs on system */
  278.     };
  279.    
  280. Lisp_Object Qdefault_subproc_input_handler;
  281.  
  282. extern int process_ef;        /* Event flag for subprocess operations */
  283.  
  284. DEFUN ("default-subprocess-input-handler",
  285.   Fdefault_subproc_input_handler, Sdefault_subproc_input_handler,
  286.   2, 2, 0,
  287.   "Default input handler for input from spawned subprocesses.")
  288.   (name, input)
  289.      Lisp_Object name, input;
  290. {
  291.   /* Just insert in current buffer */
  292.   insert (XSTRING (input)->data, XSTRING (input)->size);
  293.   insert ("\n", 1);
  294. }
  295.  
  296. DEFUN ("spawn-subprocess", Fspawn_subprocess, Sspawn_subprocess, 1, 3, 0,
  297.   "Spawns an asynchronous VMS suprocess for command processing.")
  298.   (name, input_handler, exit_handler)
  299.      Lisp_Object name, input_handler, exit_handler;
  300. {
  301.   int status;
  302.   char output_mbx_name[20];
  303.   struct dsc$descriptor_s output_mbx_dsc;
  304.   struct process_list *ptr, *p, *prev;
  305.   static int dummy = CLI$M_NOWAIT;
  306.  
  307.   CHECK_NUMBER (name, 0);
  308.   if (! input_mbx_chan)
  309.     {
  310.       if (! create_mbx (&input_mbx_dsc, input_mbx_name, &input_mbx_chan, 1))
  311.     return Qnil;
  312.       start_mbx_input ();
  313.     }
  314.   ptr = 0;
  315.   prev = 0;
  316.   while (ptr)
  317.     {
  318.       struct process_list *next = ptr->next;
  319.       if (ptr->name == XFASTINT (name)) 
  320.     {
  321.       if (ptr->process_active)
  322.         return Qt;
  323.  
  324.       /* Delete this process and run its exit handler.  */
  325.       if (prev)
  326.         prev->next = next;
  327.       else
  328.         process_list = next;
  329.       if (! NULL (ptr->exit_handler))
  330.         Feval (Fcons (ptr->exit_handler, Fcons (make_number (ptr->name),
  331.                             Qnil)));
  332.       sys$dassgn (ptr->mbx_chan);
  333.       break;
  334.     }
  335.       else
  336.     prev = ptr;
  337.       ptr = next;
  338.     }
  339.   if (! ptr)
  340.     ptr = (struct process_list *) xmalloc (sizeof (struct process_list));
  341.  
  342.   if (! create_mbx (&output_mbx_dsc, output_mbx_name, &ptr->mbx_chan, 2))
  343.     {
  344.       free (ptr);
  345.       return Qnil;
  346.     }
  347.   if (NULL (input_handler))
  348.     input_handler = Qdefault_subproc_input_handler;
  349.   ptr->input_handler = input_handler;
  350.   ptr->exit_handler = exit_handler;
  351.   message ("Creating subprocess...");
  352.   status = lib$spawn (0, &output_mbx_dsc, &input_mbx_dsc, &dummy, 0,
  353.                       &ptr->process_id, 0, 0, exit_ast, &ptr->process_active);
  354.   if (! (status & 1))
  355.     {
  356.       sys$dassgn (ptr->mbx_chan);
  357.       free (ptr);
  358.       error ("Unable to spawn subprocess");
  359.       return Qnil;
  360.     }
  361.   ptr->name = XFASTINT (name);
  362.   ptr->next = process_list;
  363.   ptr->process_active = 1;
  364.   process_list = ptr;
  365.   message ("Creating subprocess...done");
  366.   return Qt;
  367. }
  368.  
  369. static void
  370. mbx_msg (ptr, msg)
  371.      struct process_list *ptr;
  372.      char *msg;
  373. {
  374.   write_to_mbx (ptr, msg, strlen (msg));
  375. }
  376.  
  377. DEFUN ("send-command-to-subprocess",
  378.   Fsend_command_to_subprocess, Ssend_command_to_subprocess, 2, 2,
  379.   "sSend command to subprocess: \nsSend subprocess %s command: ",
  380.   "Send to VMS subprocess named NAME the string COMMAND.")
  381.   (name, command)
  382.      Lisp_Object name, command;
  383. {
  384.   struct process_list * ptr;
  385.  
  386.   CHECK_NUMBER (name, 0);
  387.   CHECK_STRING (command, 1);
  388.   for (ptr = process_list; ptr; ptr = ptr->next)
  389.     if (XFASTINT (name) == ptr->name)
  390.       {
  391.     write_to_mbx (ptr, XSTRING (command)->data,
  392.               XSTRING (command)->size);
  393.     return Qt;
  394.       }
  395.   return Qnil;
  396. }
  397.  
  398. DEFUN ("stop-subprocess", Fstop_subprocess, Sstop_subprocess, 1, 1,
  399.   "sStop subprocess: ", "Stop VMS subprocess named NAME.")
  400.   (name)
  401.      Lisp_Object name;
  402. {
  403.   struct process_list * ptr;
  404.  
  405.   CHECK_NUMBER (name, 0);
  406.   for (ptr = process_list; ptr; ptr = ptr->next)
  407.     if (XFASTINT (name) == ptr->name)
  408.       {
  409.     ptr->exit_handler = Qnil;
  410.     if (sys$delprc (&ptr->process_id, 0) & 1)
  411.       ptr->process_active = 0;
  412.     return Qt;
  413.       }
  414.   return Qnil;
  415. }
  416.  
  417. static int
  418. exit_ast (active)
  419.      int * active;
  420. {
  421.   process_exited = 1;
  422.   *active = 0;
  423.   sys$setef (process_ef);
  424. }
  425.  
  426. /* Process to handle input on the input mailbox.
  427.  * Searches through the list of processes until the matching PID is found,
  428.  * then calls its input handler.
  429.  */
  430.  
  431. process_command_input ()
  432. {
  433.   struct process_list * ptr;
  434.   char * msg;
  435.   int msglen;
  436.   Lisp_Object expr;
  437.  
  438.   msg = mbx_buffer;
  439.   msglen = input_iosb.size;
  440.   /* Hack around VMS oddity of sending extraneous CR/LF characters for
  441.    * some of the commands (but not most).
  442.    */
  443.   if (msglen > 0 && *msg == '\r')
  444.     {
  445.       msg++;
  446.       msglen--;
  447.     }
  448.   if (msglen > 0 && msg[msglen - 1] == '\n')
  449.     msglen--;
  450.   if (msglen > 0 && msg[msglen - 1] == '\r')
  451.     msglen--;
  452.   /* Search for the subprocess in the linked list.
  453.    */
  454.   expr = Qnil;
  455.   for (ptr = process_list; ptr; ptr = ptr->next)
  456.     if (ptr->process_id == input_iosb.pid)
  457.       {
  458.     expr = Fcons (ptr->input_handler,
  459.               Fcons (make_number (ptr->name),
  460.                  Fcons (make_string (msg, msglen),
  461.                     Qnil)));
  462.     break;
  463.       }
  464.   have_process_input = 0;
  465.   start_mbx_input ();
  466.   clear_waiting_for_input ();    /* Otherwise Ctl-g will cause crash. JCB */
  467.   if (! NULL (expr))
  468.     Feval (expr);
  469. }
  470.  
  471. /* Searches process list for any processes which have exited.  Calls their
  472.  * exit handlers and removes them from the process list.
  473.  */
  474.  
  475. process_exit ()
  476. {
  477.   struct process_list * ptr, * prev, * next;
  478.  
  479.   process_exited = 0;
  480.   prev = 0;
  481.   ptr = process_list;
  482.   while (ptr)
  483.     {
  484.       next = ptr->next;
  485.       if (! ptr->process_active)
  486.     {
  487.       if (prev)
  488.         prev->next = next;
  489.       else
  490.         process_list = next;
  491.       if (! NULL (ptr->exit_handler))
  492.         Feval (Fcons (ptr->exit_handler, Fcons (make_number (ptr->name),
  493.                             Qnil)));
  494.       sys$dassgn (ptr->mbx_chan);
  495.       free (ptr);
  496.     }
  497.       else
  498.     prev = ptr;
  499.       ptr = next;
  500.     }
  501. }
  502.  
  503. /* Called at emacs exit.
  504.  */
  505.  
  506. kill_vms_processes ()
  507. {
  508.   struct process_list * ptr;
  509.  
  510.   for (ptr = process_list; ptr; ptr = ptr->next)
  511.     if (ptr->process_active)
  512.       {
  513.     sys$dassgn (ptr->mbx_chan);
  514.     sys$delprc (&ptr->process_id, 0);
  515.       }
  516.   sys$dassgn (input_mbx_chan);
  517.   process_list = 0;
  518.   input_mbx_chan = 0;
  519. }
  520.  
  521. /* Creates a temporary mailbox and retrieves its device name in 'buf'.
  522.  * Makes the descriptor pointed to by 'dsc' refer to this device.
  523.  * 'buffer_factor' is used to allow sending messages asynchronously
  524.  * till some point.
  525.  */
  526.  
  527. static int
  528. create_mbx (dsc, buf, chan, buffer_factor)
  529.      struct dsc$descriptor_s *dsc;
  530.      char *buf;
  531.      int *chan;
  532.      int buffer_factor;
  533. {
  534.   int strval[2];
  535.   int status;
  536.   static int dummy = DVI$_DEVNAM;
  537.  
  538.   status = sys$crembx (0, chan, MSGSIZE, MSGSIZE * buffer_factor, 0, 0, 0);
  539.   if (! (status & 1))
  540.     {
  541.       message ("Unable to create mailbox.  Need TMPMBX privilege.");
  542.       return 0;
  543.     }
  544.   strval[0] = 16;
  545.   strval[1] = (int) buf;
  546.   status = lib$getdvi (&dummy, chan, 0, 0, strval,
  547.                &dsc->dsc$w_length);
  548.   if (! (status & 1))
  549.     return 0;
  550.   dsc->dsc$b_dtype = DSC$K_DTYPE_T;
  551.   dsc->dsc$b_class = DSC$K_CLASS_S;
  552.   dsc->dsc$a_pointer = buf;
  553.   return 1;
  554. }                /* create_mbx */
  555.  
  556. /* AST routine to be called upon receiving mailbox input.
  557.  * Sets flag telling keyboard routines that input is available.
  558.  */
  559.  
  560. static int
  561. mbx_input_ast ()
  562. {
  563.   have_process_input = 1;
  564. }
  565.  
  566. /* Issue a QIO request on the input mailbox.
  567.  */
  568. static void
  569. start_mbx_input ()
  570. {
  571.   sys$qio (process_ef, input_mbx_chan, IO$_READVBLK, &input_iosb,
  572.            mbx_input_ast, 0, mbx_buffer, sizeof (mbx_buffer),
  573.        0, 0, 0, 0);
  574. }
  575.  
  576. /* Send a message to the subprocess input mailbox, without blocking if
  577.  * possible.
  578.  */
  579. static void
  580. write_to_mbx (ptr, buf, len)
  581.      struct process_list *ptr;
  582.      char *buf;
  583.      int len;
  584. {
  585.   sys$qiow (0, ptr->mbx_chan, IO$_WRITEVBLK | IO$M_NOW, &ptr->iosb,
  586.         0, 0, buf, len, 0, 0, 0, 0);
  587. }
  588.  
  589. DEFUN ("setprv", Fsetprv, Ssetprv, 1, 3, 0,
  590.   "Set or reset a VMS privilege.  First arg is privilege name.\n\
  591. Second arg is t or nil, indicating whether the privilege is to be\n\
  592. set or reset.  Default is nil.  Returns t if success, nil if not.\n\
  593. If third arg is non-nil, does not change privilege, but returns t\n\
  594. or nil depending upon whether the privilege is already enabled.")
  595.   (priv, value, getprv)
  596.      Lisp_Object priv, value, getprv;
  597. {
  598.   int prvmask[2], prvlen, newmask[2];
  599.   unsigned char * prvname;
  600.   int found, i;
  601.   struct privilege_list * ptr;
  602.  
  603.   CHECK_STRING (priv, 0);
  604.   priv = Fupcase (priv);
  605.   prvname = XSTRING (priv)->data;
  606.   prvlen = XSTRING (priv)->size;
  607.   found = 0;
  608.   prvmask[0] = 0;
  609.   prvmask[1] = 0;
  610.   for (i = 0; i < sizeof (priv_list) / sizeof (priv_list[0]); i++)
  611.     {
  612.       ptr = &priv_list[i];
  613.       if (prvlen == strlen (ptr->name) &&
  614.       bcmp (prvname, ptr->name, prvlen) == 0)
  615.     {
  616.       if (ptr->mask >= 32)
  617.         prvmask[1] = 1 << (ptr->mask % 32);
  618.       else
  619.         prvmask[0] = 1 << ptr->mask;
  620.       found = 1;
  621.       break;
  622.     }
  623.     }
  624.   if (! found)
  625.     error ("Unknown privilege name %s", XSTRING (priv)->data);
  626.   if (NULL (getprv))
  627.     {
  628.       if (sys$setprv (NULL (value) ? 0 : 1, prvmask, 0, 0) == SS$_NORMAL)
  629.     return Qt;
  630.       return Qnil;
  631.     }
  632.   /* Get old priv value */
  633.   if (sys$setprv (0, 0, 0, newmask) != SS$_NORMAL)
  634.     return Qnil;
  635.   if ((newmask[0] & prvmask[0])
  636.       || (newmask[1] & prvmask[1]))
  637.     return Qt;
  638.   return Qnil;
  639. }
  640.  
  641. /* Retrieves VMS system information.  */
  642.  
  643. #ifdef VMS4_4  /* I don't know whether these functions work in old versions */
  644.  
  645. DEFUN ("vms-system-info", Fvms_system_info, Svms_system_info, 1, 3, 0,
  646.   "Retrieve VMS process and system information.\n\
  647. The first argument (a string) specifies the type of information desired.\n\
  648. The other arguments depend on the type you select.\n\
  649. For information about a process, the second argument is a process ID\n\
  650. or a process name, with the current process as a default.\n\
  651. These are the possibilities for the first arg (upper or lower case ok):\n\
  652.     account     Returns account name\n\
  653.     cliname     Returns CLI name\n\
  654.     owner       Returns owner process's PID\n\
  655.     grp         Returns group number\n\
  656.     parent      Returns parent process's PID\n\
  657.     pid         Returns process's PID\n\
  658.     prcnam      Returns process's name\n\
  659.     terminal    Returns terminal name\n\
  660.     uic         Returns UIC number\n\
  661.     uicgrp      Returns formatted [UIC,GRP]\n\
  662.     username    Returns username\n\
  663.     version     Returns VMS version\n\
  664.     logical     Translates VMS logical name (second argument)\n\
  665.     dcl-symbol  Translates DCL symbol (second argument)\n\
  666.     proclist    Returns list of all PIDs on system (needs WORLD privilege)." )
  667.   (type, arg1, arg2)
  668.      Lisp_Object type, arg1, arg2;
  669. {
  670.   int i, typelen;
  671.   unsigned char * typename;
  672.   struct vms_objlist * ptr;
  673.  
  674.   CHECK_STRING (type, 0);
  675.   type = Fupcase (type);
  676.   typename = XSTRING (type)->data;
  677.   typelen = XSTRING (type)->size;
  678.   for (i = 0; i < sizeof (vms_object) / sizeof (vms_object[0]); i++)
  679.     {
  680.       ptr = &vms_object[i];
  681.       if (typelen == strlen (ptr->name)
  682.       && bcmp (typename, ptr->name, typelen) == 0)
  683.     return (* ptr->objfn)(arg1, arg2);
  684.     }
  685.   error ("Unknown object type %s", typename);
  686. }
  687.  
  688. /* Given a reference to a VMS process, returns its process id.  */
  689.  
  690. static int
  691. translate_id (pid, owner)
  692.      Lisp_Object pid;
  693.      int owner;        /* if pid is null/0, return owner.  If this
  694.              * flag is 0, return self. */
  695. {
  696.   int status, code, id, i, numeric, size;
  697.   unsigned char * p;
  698.   int prcnam[2];
  699.   static int dummy = JPI$_PID;
  700.  
  701.   if (NULL (pid)
  702.       || XTYPE (pid) == Lisp_String && XSTRING (pid)->size == 0
  703.       || XTYPE (pid) == Lisp_Int && XFASTINT (pid) == 0)
  704.     {
  705.       code = owner ? JPI$_OWNER : JPI$_PID;
  706.       status = lib$getjpi (&code, 0, 0, &id);
  707.       if (! (status & 1))
  708.     error ("Cannot find %s: %s",
  709.            owner ? "owner process" : "process id",
  710.            vmserrstr (status));
  711.       return (id);
  712.     }
  713.   if (XTYPE (pid) == Lisp_Int)
  714.     return (XFASTINT (pid));
  715.   CHECK_STRING (pid, 0);
  716.   pid = Fupcase (pid);
  717.   size = XSTRING (pid)->size;
  718.   p = XSTRING (pid)->data;
  719.   numeric = 1;
  720.   id = 0;
  721.   for (i = 0; i < size; i++, p++)
  722.     if (isxdigit (*p))
  723.       {
  724.     id *= 16;
  725.     if (*p >= '0' && *p <= '9')
  726.       id += *p - '0';
  727.     else
  728.       id += *p - 'A' + 10;
  729.       }
  730.     else
  731.       {
  732.     numeric = 0;
  733.     break;
  734.       }
  735.   if (numeric)
  736.     return (id);
  737.   prcnam[0] = XSTRING (pid)->size;
  738.   prcnam[1] = (int) XSTRING (pid)->data;
  739.   status = lib$getjpi (&dummy, 0, prcnam, &id);
  740.   if (! (status & 1))
  741.     error ("Cannot find process id: %s",
  742.        vmserrstr (status));
  743.   return (id);
  744. }                /* translate_id */
  745.  
  746. /* VMS object retrieval functions.  */
  747.  
  748. static Lisp_Object
  749. getjpi (jpicode, arg, numeric)
  750.      int jpicode;        /* Type of GETJPI information */
  751.      Lisp_Object arg;
  752.      int numeric;        /* 1 if numeric value expected */
  753. {
  754.   int id, status, numval;
  755.   char str[128];
  756.   int strdsc[2] = { sizeof (str), (int) str };
  757.   short strlen;
  758.  
  759.   id = translate_id (arg, 0);
  760.   status = lib$getjpi (&jpicode, &id, 0, &numval, strdsc, &strlen);
  761.   if (! (status & 1))
  762.     error ("Unable to retrieve information: %s",
  763.        vmserrstr (status));
  764.   if (numeric)
  765.     return (make_number (numval));
  766.   return (make_string (str, strlen));
  767. }
  768.  
  769. static Lisp_Object
  770. vms_account (arg1, arg2)
  771.      Lisp_Object arg1, arg2;
  772. {
  773.   return getjpi (JPI$_ACCOUNT, arg1, 0);
  774. }
  775.  
  776. static Lisp_Object
  777. vms_cliname (arg1, arg2)
  778.      Lisp_Object arg1, arg2;
  779. {
  780.   return getjpi (JPI$_CLINAME, arg1, 0);
  781. }
  782.  
  783. static Lisp_Object
  784. vms_grp (arg1, arg2)
  785.      Lisp_Object arg1, arg2;
  786. {
  787.   return getjpi (JPI$_GRP, arg1, 1);
  788. }
  789.  
  790. static Lisp_Object
  791. vms_image (arg1, arg2)
  792.      Lisp_Object arg1, arg2;
  793. {
  794.   return getjpi (JPI$_IMAGNAME, arg1, 0);
  795. }
  796.  
  797. static Lisp_Object
  798. vms_owner (arg1, arg2)
  799.      Lisp_Object arg1, arg2;
  800. {
  801.   return getjpi (JPI$_OWNER, arg1, 1);
  802. }
  803.  
  804. static Lisp_Object
  805. vms_parent (arg1, arg2)
  806.      Lisp_Object arg1, arg2;
  807. {
  808.   return getjpi (JPI$_MASTER_PID, arg1, 1);
  809. }
  810.  
  811. static Lisp_Object
  812. vms_pid (arg1, arg2)
  813.      Lisp_Object arg1, arg2;
  814. {
  815.   return getjpi (JPI$_PID, arg1, 1);
  816. }
  817.  
  818. static Lisp_Object
  819. vms_prcnam (arg1, arg2)
  820.      Lisp_Object arg1, arg2;
  821. {
  822.   return getjpi (JPI$_PRCNAM, arg1, 0);
  823. }
  824.  
  825. static Lisp_Object
  826. vms_terminal (arg1, arg2)
  827.      Lisp_Object arg1, arg2;
  828. {
  829.   return getjpi (JPI$_TERMINAL, arg1, 0);
  830. }
  831.  
  832. static Lisp_Object
  833. vms_uic_int (arg1, arg2)
  834.      Lisp_Object arg1, arg2;
  835. {
  836.   return getjpi (JPI$_UIC, arg1, 1);
  837. }
  838.  
  839. static Lisp_Object
  840. vms_uic_str (arg1, arg2)
  841.      Lisp_Object arg1, arg2;
  842. {
  843.   return getjpi (JPI$_UIC, arg1, 0);
  844. }
  845.  
  846. static Lisp_Object
  847. vms_username (arg1, arg2)
  848.      Lisp_Object arg1, arg2;
  849. {
  850.   return getjpi (JPI$_USERNAME, arg1, 0);
  851. }
  852.  
  853. static Lisp_Object
  854. vms_version_fn (arg1, arg2)
  855.      Lisp_Object arg1, arg2;
  856. {
  857.   char str[256];        /* Max logical translation is 255 bytes.  */
  858.   int status;
  859.   int strdsc[2] = { sizeof (str), (int) str };
  860.   short strlen;
  861.   static int dummy = SYI$_VERSION;
  862.  
  863.   status = lib$getsyi (&dummy, 0, strdsc, &strlen, 0, 0);
  864.   if (! (status & 1))
  865.     error ("Unable to obtain version: %s", vmserrstr (status));
  866.   return (make_string (str, strlen));
  867. }
  868.  
  869. static Lisp_Object
  870. vms_trnlog (arg1, arg2)
  871.      Lisp_Object arg1, arg2;
  872. {
  873.   char str[1025];        /* Max symbol translation is 1024 bytes.  */
  874.   int status, symdsc[2];
  875.   int strdsc[2] = { sizeof (str), (int) str };
  876.   short length, level;
  877.  
  878.   CHECK_STRING (arg1, 0);
  879.   symdsc[0] = XSTRING (arg1)->size;
  880.   symdsc[1] = (int) XSTRING (arg1)->data;
  881.   status = lib$sys_trnlog (symdsc, &length, strdsc);
  882.   if (! (status & 1))
  883.     error ("Unable to translate logical name: %s", vmserrstr (status));
  884.   if (status == SS$_NOTRAN)
  885.     return (Qnil);
  886.   return (make_string (str, length));
  887. }
  888.  
  889. static Lisp_Object
  890. vms_symbol (arg1, arg2)
  891.      Lisp_Object arg1, arg2;
  892. {
  893.   char str[100];
  894.   int status, symdsc[2];
  895.   int strdsc[2] = { sizeof (str), (int) str };
  896.   short length, level;
  897.  
  898.   CHECK_STRING (arg1, 0);
  899.   symdsc[0] = XSTRING (arg1)->size;
  900.   symdsc[1] = (int) XSTRING (arg1)->data;
  901.   status = lib$get_symbol (symdsc, strdsc, &length, &level);
  902.   if (! (status & 1)) {
  903.     if (status == LIB$_NOSUCHSYM)
  904.       return (Qnil);
  905.     else
  906.       error ("Unable to translate symbol: %s", vmserrstr (status));
  907.   }
  908.   return (make_string (str, length));
  909. }
  910.  
  911. static Lisp_Object
  912. vms_proclist (arg1, arg2)
  913.      Lisp_Object arg1, arg2;
  914. {
  915.   Lisp_Object retval;
  916.   int id, status, pid;
  917.   static int dummy = JPI$_PID;
  918.  
  919.   retval = Qnil;
  920.   pid = -1;
  921.   for (;;)
  922.     {
  923.       status = lib$getjpi (&dummy, &pid, 0, &id);
  924.       if (status == SS$_NOMOREPROC)
  925.     break;
  926.       if (! (status & 1))
  927.     error ("Unable to get process ID: %s", vmserrstr (status));
  928.       retval = Fcons (make_number (id), retval);
  929.     }
  930.   return (Fsort (retval, intern ("<")));
  931. }
  932.  
  933. DEFUN ("shrink-to-icon", Fshrink_to_icon, Sshrink_to_icon, 0, 0, 0,
  934.       "If emacs is running in a workstation window, shrink to an icon.")
  935.      ()
  936. {
  937.   static char result[128];
  938.   static $DESCRIPTOR (result_descriptor, result);
  939.   static $DESCRIPTOR (tt_name, "TT:");
  940.   static int chan = 0;
  941.   static int buf = 0x9d + ('2'<<8) + ('2'<<16) + (0x9c<<24);
  942.   int status;
  943.   static int temp = JPI$_TERMINAL;
  944.  
  945.   status = lib$getjpi (&temp, 0, 0, 0, &result_descriptor, 0);
  946.   if (status != SS$_NORMAL)
  947.     error ("Unable to determine terminal type.");
  948.   if (result[0] != 'W' || result[1] != 'T') /* see if workstation */
  949.     error ("Can't shrink-to-icon on a non workstation terminal");
  950.   if (!chan)                /* assign channel if not assigned */
  951.     if ((status = sys$assign (&tt_name, &chan, 0, 0)) != SS$_NORMAL)
  952.       error ("Can't assign terminal, %d", status);
  953.   status = sys$qiow (0, chan, IO$_WRITEVBLK+IO$M_BREAKTHRU, 0, 0, 0,
  954.              &buf, 4, 0, 0, 0, 0);
  955.   if (status != SS$_NORMAL)
  956.     error ("Can't shrink-to-icon, %d", status);
  957. }
  958.  
  959. #endif /* VMS4_4 */
  960.  
  961. init_vmsfns ()
  962. {
  963.   process_list = 0;
  964.   input_mbx_chan = 0;
  965. }
  966.  
  967. syms_of_vmsfns ()
  968. {
  969.   defsubr (&Sdefault_subproc_input_handler);
  970.   defsubr (&Sspawn_subprocess);
  971.   defsubr (&Ssend_command_to_subprocess);
  972.   defsubr (&Sstop_subprocess);
  973.   defsubr (&Ssetprv);
  974. #ifdef VMS4_4
  975.   defsubr (&Svms_system_info);
  976.   defsubr (&Sshrink_to_icon);
  977. #endif /* VMS4_4 */
  978.   Qdefault_subproc_input_handler = intern ("default-subprocess-input-handler");
  979.   staticpro (&Qdefault_subproc_input_handler);
  980. }
  981. #endif /* VMS */
  982.  
  983.